home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 October / macformat-005.iso / Shareware City / Developers / xlispmac / lisp / COMMON.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-28  |  17.7 KB  |  603 lines  |  [TEXT/xlsp]
  1. ;; functions missing that are part of common lisp, and commonly used
  2.  
  3. ;; It is assumed you are using XLISP 2.1g with all Common Lisp related options
  4. ;; turned on before you load this file.
  5.  
  6. ;; Author either unknown or Tom Almy unless indicated.
  7.  
  8. (in-package "XLISP")
  9.  
  10. ; (unintern sym) - remove a symbol from the oblist
  11. #-:packages
  12. (defun unintern (symbol)
  13.   (let ((subhash (hash symbol (length *obarray*))))
  14.     (cond ((member symbol (aref *obarray* subhash))
  15.              (setf (aref *obarray* subhash)
  16.                    (delete symbol (aref *obarray* subhash)))
  17.              t)
  18.           (t nil))))
  19.  
  20. (export '(pairlis copy-list copy-alist copy-tree signum))
  21.  
  22. ;; pairlis does not check for lengths of keys and values being unequal
  23.  
  24. (defun pairlis (keys values &optional list)
  25.        (nconc (mapcar #'cons keys values) list))
  26.  
  27. (defun copy-list (list) (append list 'nil))
  28.  
  29. (defun copy-alist (list)
  30.     (if (null list)
  31.         'nil
  32.         (cons (if (consp (car list))
  33.           (cons (caar list) (cdar list))
  34.           (car list))
  35.           (copy-alist (cdr list)))))
  36.  
  37. (defun copy-tree (list)
  38.     (if (consp list)
  39.         (cons (copy-tree (car list)) (copy-tree (cdr list)))
  40.         list))
  41.  
  42. (defun signum (x)
  43.    (cond ((not (numberp x)) (error "~s is not a number" x))
  44.          ((zerop x) x)
  45.      (T (/ x (abs x)))))  
  46.  
  47. (export '(remf incf decf push pushnew pop))
  48.  
  49. ; Cruddy but simple versions of these functions.
  50. ; Commented out since XLISP will now expand macros once, making
  51. ; good version much preferred.
  52.  
  53. ;(defmacro incf (var &optional (delta 1))
  54. ;    `(setf ,var (+ ,var ,delta)))
  55.  
  56. ;(defmacro decf (var &optional (delta 1))
  57. ;    `(setf ,var (- ,var ,delta)))
  58.  
  59. ;(defmacro push (v l)
  60. ;    `(setf ,l (cons ,v ,l))))
  61.  
  62. ;(defmacro pushnew (a l &rest args)
  63. ;  `(unless (member ,a ,l ,@args) (push ,a ,l) nil))
  64.  
  65. ;(defmacro pop (l)
  66. ;    `(prog1 (first ,l) (setf ,l (rest ,l)))))
  67.  
  68.  
  69. ; This is what one really needs to do for incf decf and
  70. ; (in common.lsp) push and pop. The setf form must only be evaluated once.
  71. ; But is it worth all this overhead for correctness?
  72. ; (By Tom Almy)
  73.  
  74. (defun |DoForm| (form) ; returns (cons |list for let| |new form|)
  75.        (let* ((args (rest form)) ; raw form arguments
  76.           (letlist (mapcan #'(lambda (x) (when (consp x)
  77.                            (list (list (gensym) x))))
  78.                    form))
  79.           (revlist (mapcar #'(lambda (x) (cons (second x) (first x)))
  80.                    letlist))
  81.           (newform (cons (first form) (sublis revlist args))))
  82.          (cons letlist newform)))
  83.  
  84. (defun |RemProp| (l prop)
  85.        (do ((cl l (cddr cl))
  86.         (flg nil cl))
  87.        ((atom cl) nil)    ; none found 
  88.        (cond ((atom (cdr l)) 
  89.           (error "odd length property list"))
  90.          ((eq (car cl) prop) ; a match!
  91.           (if flg ; different if first in list from later 
  92.               (rplacd (cdr flg) (cddr cl))
  93.               (setq l (cddr l)))
  94.           (return (list l))))))
  95.  
  96. (defmacro remf (form prop &aux (remres (gensym)))
  97.       (if (and (consp form) (some #'consp form))
  98.           (let ((retval (|DoForm| form)))
  99.            `(let* ( ,@(car retval)
  100.                 (,remres (|RemProp| ,(cdr retval) ,prop)))
  101.               (if ,remres
  102.                   (progn (setf ,(cdr retval) (car ,remres))
  103.                      t)
  104.                   nil)))
  105.           `(let ((,remres (|RemProp| ,form ,prop)))
  106.             (if ,remres (progn (setf ,form (car ,remres)) t)
  107.             nil))))
  108.  
  109. #-packages
  110. (unintern '|RemProp|)
  111.  
  112. (defmacro incf (form &optional (delta 1))
  113.       (if (and (consp form) (some #'consp form))
  114.           (let ((retval (|DoForm| form)))
  115.            `(let ,(car retval) 
  116.              (setf ,(cdr retval)
  117.                    (+ ,(cdr retval) ,delta))))
  118.           `(setf ,form (+ ,form ,delta))))
  119.  
  120. (defmacro decf (form &optional (delta 1))
  121.       (if (and (consp form) (some #'consp form))
  122.           (let ((retval (|DoForm| form)))
  123.            `(let ,(car retval) 
  124.              (setf ,(cdr retval)
  125.                    (- ,(cdr retval) ,delta))))
  126.           `(setf ,form (- ,form ,delta))))
  127.  
  128. (defmacro push (val form)
  129.       (if (and (consp form) (some #'consp form))
  130.           (let ((retval (|DoForm| form)))
  131.            `(let ,(car retval) 
  132.              (setf ,(cdr retval)
  133.                    (cons ,val ,(cdr retval)))))
  134.           `(setf ,form (cons ,val ,form))))
  135.  
  136. (defmacro pop (form)
  137.       (if (and (consp form) (some #'consp form))
  138.           (let ((retval (|DoForm| form)))
  139.            `(let ,(car retval) 
  140.              (prog1 (first ,(cdr retval))
  141.                 (setf ,(cdr retval)
  142.                       (rest ,(cdr retval))))))
  143.           `(prog1 (first ,form)
  144.               (setf ,form (rest ,form)))))
  145.  
  146.  
  147. (defmacro pushnew (val form &rest rest)
  148.       (if (and (consp form) (some #'consp form))
  149.           (let ((retval (|DoForm| form)))
  150.            `(let ,(car retval) 
  151.              (setf ,(cdr retval)
  152.                    (adjoin ,val ,(cdr retval) ,@rest))))
  153.           `(setf ,form (adjoin ,val ,form ,@rest))))
  154.  
  155. #-packages
  156. (unintern '|DoForm|)
  157.  
  158. ;; Hyperbolic functions    Ken Whedbee  from CLtL
  159.  
  160. (export '(logtest cis sinh cosh tanh asinh acosh atanh))
  161.  
  162. (defun logtest (x y) (not (zerop (logand x y))))
  163.  
  164. (defconstant imag-one #C(0.0 1.0))
  165.  
  166. (defun cis (x) (exp (* imag-one x)))
  167.  
  168.  
  169. (defun sinh (x) (/ (- (exp x) (exp (- x))) 2.0))
  170. (defun cosh (x) (/ (+ (exp x) (exp (- x))) 2.0))
  171. (defun tanh (x) (/ (sinh x) (cosh x)))
  172.  
  173. (defun asinh (x) (log (+ x (sqrt (+ 1.0 (* x x))))))
  174. (defun acosh (x)
  175.        (log (+ x
  176.                (* (1+ x)
  177.                     (sqrt (/ (1- x) (1+ x)))))))
  178. (defun atanh (x)
  179.        (when (or (= x 1.0) (= x -1.0))
  180.              (error "~s is a logarithmic singularity" x))
  181.        (log (/ (1+ x) (sqrt (- 1.0 (* x x))))))
  182.     
  183.  
  184.  
  185. ;; Additional Common Lisp Functions by Luke Tierney
  186. ;; from xlisp-stat
  187.  
  188. ;;
  189. ;; Defsetf and documentation functions
  190. ;; Corrected for Common Lisp compatibility (requires XLISP-PLUS 2.1e)
  191. ;;  Modified by Tom Almy, 7/92
  192. ;;  Corrected again in 6/93
  193. ;;  and again (Luke Tierney) 11/93
  194. ;;
  195.  
  196. (export '(defsetf))
  197.  
  198. (defun apply-arg-rotate (f args) 
  199.   (apply f (list 'quote (car (last args))) (butlast args)))
  200.  
  201. ; (defsetf) - define setf method
  202. (defmacro defsetf (sym first &rest rest)
  203.   (if (symbolp first)
  204.       `(progn (setf (get ',sym '*setf*) #',first)
  205.           (remprop ',sym '*setf-lambda*)
  206.           ',sym)
  207.       (let ((f `#'(lambda ,(append (car rest) first) ,@(cdr rest)))
  208.             (args (gensym)))
  209.         `(progn
  210.           (setf (get ',sym '*setf-lambda*) ; changed *setf* to *setf-lambda*
  211.                 #'(lambda (&rest ,args) (apply-arg-rotate ,f ,args)))
  212.       (remprop ',sym '*setf*)
  213.           ',sym))))
  214.  
  215.  
  216. ;;;;
  217. ;;;;
  218. ;;;; Modules, provide and require:  Luke Tierney, from xlisp-stat
  219. ;;;;
  220. ;;;;
  221.  
  222. ; Uncomment these if you want them. It's non-standard, and nothing else
  223. ; in this distribution  uses them, so I'm commenting them out.  Tom Almy
  224.  
  225. #|
  226. (defvar *modules*)
  227.     
  228. (defun provide (name)
  229.   (pushnew name *modules* :test #'equal))
  230.   
  231. (defun require (name &optional (path name))
  232.   (let ((name (string name))
  233.         (path (string path)))
  234.     (unless (member name *modules* :test #'equal)
  235.             (if (load path)
  236.                 t
  237.         (load (strcat *default-path* path))))))
  238. |#
  239. ;;;;
  240. ;;;;
  241. ;;;; Miscellaneous Functions:  Luke Tierney
  242. ;;;;    from xlisp-stat
  243. ;;;;
  244.  
  245. (export '(equalp y-or-n-p yes-or-no-p functionp with-input-from-string
  246.           with-output-to-string with-open-file))
  247.  
  248. ; equalp rewritten by Tom Almy to better match Common Lisp
  249. (defun equalp (x y)
  250.   (cond ((equal x y) t)
  251.       ((numberp x) (if (numberp y) (= x y) nil))
  252.       ((characterp x) (if (characterp y) (char-equal x y) nil))
  253.       ((and (or (arrayp x) (stringp x)) 
  254.             (or (arrayp y) (stringp y))
  255.             (eql (length x) (length y)))
  256.        (every #'equalp x y))))
  257.  
  258. ; Modified by TAA
  259. #-:getkey
  260. (defun y-or-n-p (&rest args)
  261.        (reset-system)
  262.        (when args (fresh-line) (apply #'format *terminal-io* args))
  263.        (do ((answer (string-trim " " (read-line))
  264.             (string-trim " " (read-line))))
  265.        ((or (string-equal answer "Y")
  266.         (string-equal answer "N"))
  267.         (string-equal answer "Y"))
  268.        (princ " Answer \"y\" or \"n\": " *terminal-io*)))
  269.  
  270. #+:getkey
  271. (defun y-or-n-p (&rest args)
  272.        (when args (fresh-line) (apply #'format *terminal-io* args))
  273.        (do ((answer (princ (int-char (get-key)))
  274.             (princ (int-char (get-key)))))
  275.        ((or (char-equal answer #\Y)
  276.         (char-equal answer #\N))
  277.         (char-equal answer #\Y))
  278.        (princ "\nAnswer \"y\" or \"n\": " *terminal-io*)))
  279.  
  280.  
  281. ; Based on y-or-n-p
  282. (defun yes-or-no-p (&rest args)
  283.        (reset-system)
  284.        (when args (fresh-line) (apply #'format *terminal-io* args))
  285.        (do ((answer (string-trim " " (read-line))
  286.             (string-trim " " (read-line))))
  287.        ((or (string-equal answer "YES")
  288.         (string-equal answer "NO"))
  289.         (string-equal answer "YES"))
  290.        (princ " Answer \"yes\" or \"no\": " *terminal-io*)))
  291.  
  292. ; Improved by TAA to match common lisp definition
  293. (defun functionp (x)
  294.     (if (typep x '(or closure subr symbol))
  295.     t
  296.         (and (consp x) (eq (car x) 'lambda))))
  297.  
  298. ;(defmacro with-input-from-string (stream-string &rest body)
  299. ;  (let ((stream (first stream-string))
  300. ;        (string (second stream-string)))
  301. ;    `(let ((,stream (make-string-input-stream ,string)))
  302. ;       (progn ,@body))))
  303.  
  304.  
  305. (defmacro with-input-from-string
  306.       (stream-string &rest body)
  307.       (let ((stream (first stream-string))
  308.         (string (second stream-string))
  309.         (start (second (member :start (cddr stream-string))))
  310.         (end (second (member :end (cddr stream-string))))
  311.         (index (second (member :index (cddr stream-string)))))
  312.            (when (null start) (setf start 0))
  313.            (if index
  314.            (let ((str (gensym)))
  315.             `(let* ((,str ,string)
  316.                 (,stream (make-string-input-stream ,str 
  317.                                    ,start 
  318.                                    ,end)))
  319.                (prog1 (progn ,@body)
  320.                   (setf ,index 
  321.                     (- (length ,str)
  322.                        (length (get-output-stream-list 
  323.                              ,stream)))))))
  324.            `(let ((,stream (make-string-input-stream ,string ,start ,end)))
  325.              (progn ,@body)))))
  326.            
  327.  
  328. (defmacro with-output-to-string (str-list &rest body)
  329.   (let ((stream (first str-list)))
  330.     `(let ((,stream (make-string-output-stream)))
  331.        (progn ,@body)
  332.        (get-output-stream-string ,stream))))
  333.  
  334. (defmacro with-open-file (stream-file-args &rest body)
  335.   (let ((stream (first stream-file-args))
  336.         (file-args (rest stream-file-args)))
  337.     `(let ((,stream (open ,@file-args)))
  338.        (unwind-protect 
  339.            (progn ,@body)
  340.          (when ,stream (close ,stream))))))
  341.  
  342. (export '(eval-when declare proclaim special))
  343. ;; Dummy function to allow importing CL code
  344. (defmacro eval-when (when &rest body)
  345.   (if (or (member 'eval when) (member 'execute when))
  346.       `(progn ,@body)))
  347. (defmacro declare (&rest args)
  348.   (if *displace-macros*
  349.       (dolist (a args)
  350.         (if (eq (first a) 'special)
  351.         (return (cerror "special ignored"
  352.                 "special declarations are not supported"))))))
  353. (defun proclaim (decl)
  354.   (if (eq (first decl) 'special)
  355.       (dolist (s (rest decl))
  356.         (mark-as-special s))))
  357.  
  358.  
  359. ;; array functions.   KCW    from  Kyoto Common Lisp
  360.  
  361. (export '(fill replace acons))
  362.  
  363. (defun fill (sequence item
  364.              &key (start 0) end)
  365.        (when (null end) (setf end (length sequence)))
  366.        (do ((i start (1+ i)))
  367.        ((>= i end) sequence)
  368.        (setf (elt sequence i) item)))
  369.  
  370.  
  371. (defun replace (sequence1 sequence2
  372.                 &key (start1 0) end1
  373.                      (start2 0) end2)
  374.     (when (null end1) (setf end1 (length sequence1)))
  375.     (when (null end2) (setf end2 (length sequence2)))
  376.     (if (and (eq sequence1 sequence2)
  377.              (> start1 start2))
  378.         (do* ((i 0 (1+ i))
  379.               (l (if (< (- end1 start1) (- end2 start2))
  380.                      (- end1 start1)
  381.                      (- end2 start2)))
  382.               (s1 (+ start1 (1- l)) (1- s1))
  383.               (s2 (+ start2 (1- l)) (1- s2)))
  384.             ((>= i l) sequence1)
  385.           (setf (elt sequence1 s1) (elt sequence2 s2)))
  386.         (do ((i 0 (1+ i))
  387.              (l (if (< (- end1 start1)(- end2 start2))
  388.                     (- end1 start1)
  389.                     (- end2 start2)))
  390.              (s1 start1 (1+ s1))
  391.              (s2 start2 (1+ s2)))
  392.             ((>= i l) sequence1)
  393.           (setf (elt sequence1 s1) (elt sequence2 s2)))))
  394.  
  395.  
  396. (defun acons (x y a)         ; from CLtL
  397.    (cons (cons x y) a))
  398.  
  399.  
  400. ;; more set functions.  KCW    from Kyoto Common Lisp
  401.  
  402. ;; Modified to pass keys to subfunctions without checking here
  403. ;; (more efficient)
  404.  
  405. ;; (Tom Almy states:) we can't get the destructive versions of union
  406. ;; intersection, and set-difference to run faster than the non-destructive
  407. ;; subrs. Therefore we will just have the destructive versions do their
  408. ;; non-destructive counterparts
  409.  
  410. (export '(nunion nintersection nset-difference
  411.       set-exclusive-or nset-exclusive-or))
  412.  
  413. (setf (symbol-function 'nunion) 
  414.       (symbol-function 'union)
  415.       (symbol-function 'nintersection) 
  416.       (symbol-function 'intersection)
  417.       (symbol-function 'nset-difference) 
  418.       (symbol-function 'set-difference))
  419.  
  420. (defun set-exclusive-or (list1 list2 &rest rest)
  421.   (append (apply #'set-difference list1 list2 rest)
  422.           (apply #'set-difference list2 list1 rest)))
  423.  
  424. (defun nset-exclusive-or (list1 list2 &rest rest)
  425.   (nconc (apply #'set-difference list1 list2 rest)
  426.          (apply #'set-difference list2 list1 rest)))
  427.  
  428.  
  429.  
  430. ;;;;;
  431. ;;;;; Symbol and Package Functions
  432. ;;;;;
  433. #+:packages
  434. (export '(defpackage do-symbols do-external-symbols do-all-symbols
  435.       apropos apropos-list))
  436.  
  437. #+:packages
  438. (defmacro do-symbol-arrays (s res a body)
  439.   (let ((arraysym (gensym))
  440.     (isym (gensym))
  441.     (asym (gensym))
  442.     (listsym (gensym)))     
  443.     `(let ((,arraysym ,a)
  444.        (,isym 0)
  445.        (,asym nil)
  446.        (,listsym nil)
  447.        (,s nil))
  448.        (block nil
  449.          (tagbody
  450.       new-array
  451.       (when (null ,arraysym)
  452.         (setf ,s nil)
  453.         (return ,res))
  454.       (setf ,asym (first ,arraysym) ,arraysym (rest ,arraysym) ,isym -1)
  455.       new-list
  456.       (setf ,isym (1+ ,isym))
  457.       (if (<= 199 ,isym) (go new-array))
  458.       (setf ,listsym (aref ,asym ,isym))
  459.       new-item
  460.       (if (null ,listsym) (go new-list))
  461.       (setf ,s (first ,listsym) ,listsym (rest ,listsym))
  462.       (tagbody ,@body)
  463.       (go new-item))))))
  464.  
  465. #+:packages
  466. (defmacro do-symbols (spr &rest body)
  467.   (let ((packsym (gensym))
  468.     (usessym (gensym))
  469.     (arraysym (gensym)))
  470.     `(let* ((,packsym ,(if (second spr) (second spr) '*package*))
  471.         (,usessym (package-use-list ,packsym))
  472.         (,arraysym (cons (package-obarray ,packsym nil)
  473.                  (mapcar #'package-obarray
  474.                      (cons ,packsym ,usessym)))))
  475.        (do-symbol-arrays ,(first spr) ,(third spr) ,arraysym ,body))))
  476.  
  477. #+:packages
  478. (defmacro do-external-symbols (spr &rest body)
  479.   (let ((packsym (gensym))
  480.     (arraysym (gensym)))
  481.     `(let* ((,packsym ,(if (second spr) (second spr) '*package*))
  482.         (,arraysym (list (package-obarray ,packsym))))
  483.        (do-symbol-arrays ,(first spr) ,(third spr) ,arraysym ,body))))
  484.  
  485. #+:packages
  486. (defmacro do-all-symbols (sr &rest body)
  487.   (let ((packsym (gensym))
  488.     (arraysym (gensym)))
  489.     `(let* ((,packsym (list-all-packages))
  490.         (,arraysym nil))
  491.        (dolist (p ,packsym)
  492.          (push (package-obarray p) ,arraysym)
  493.      (push (package-obarray p nil) ,arraysym))
  494.        (do-symbol-arrays ,(first sr) ,(second sr) ,arraysym ,body))))
  495.  
  496. #+:packages
  497. (defmacro defpackage (pname &rest options)
  498.   `(let* ((pname ',pname)
  499.       (options ',options)
  500.       (pack (find-package ',pname))
  501.       (nicknames nil))
  502.      (dolist (opt options)
  503.        (if (eq (first opt) :nicknames)
  504.        (setf nicknames (append (rest opt) nicknames))))
  505.      (if pack
  506.      (rename-package pack
  507.              pname
  508.              (mapcar #'string
  509.                  (append nicknames (package-nicknames pack))))
  510.          (setf pack (make-package pname :nicknames 
  511.                   (mapcar #'string nicknames))))
  512.      (dolist (opt options)
  513.        (case (first opt)
  514.          (:shadow (shadow (mapcar #'string (rest opt)) pack))
  515.      (:shadowing-import-from
  516.       (let ((from-pack (find-package (second opt))))
  517.         (dolist (sname (rest (rest opt)))
  518.           (multiple-value-bind (sym found)
  519.                    (find-symbol (string sname) from-pack)
  520.             (if found
  521.             (shadowing-import sym pack)
  522.             (error "no symbol named ~s in package ~s"
  523.                (string sname)
  524.                from-pack))))))))
  525.      (dolist (opt options)
  526.        (if (eq (first opt) :use)
  527.        (use-package (mapcar #'string (rest opt)) pack)))
  528.      (dolist (opt options)
  529.        (case (first opt)
  530.          (:intern
  531.       (dolist (sname (rest opt)) (intern (string sname) pack)))
  532.      (:import-from
  533.       (let ((from-pack (find-package (second opt))))
  534.         (dolist (sname (rest (rest opt)))
  535.           (multiple-value-bind (sym found)
  536.                    (find-symbol (string sname) from-pack)
  537.             (if found
  538.             (import sym pack)
  539.             (error "no symbol named ~s in package ~s"
  540.                (string sname)
  541.                from-pack))))))))
  542.      (dolist (opt options)
  543.        (if (eq (first opt) :export)
  544.        (dolist (sname (rest opt))
  545.          (export (intern (string sname) pack) pack))))
  546.      pack))
  547.  
  548. #+:packages
  549. (defun apropos2 (s)
  550.        (format t "~&~s" s)
  551.        (when (fboundp s) (format t "  Function"))
  552.        (if (constantp s)
  553.        (format t "  Constant=~s" (symbol-value s))
  554.        (when (boundp s) (format t "  Value=~s" (symbol-value s)))))
  555.        
  556. #+:packages
  557. (defun apropos (x &optional package)
  558.        (if package
  559.        (do-symbols (s package)
  560.                (if (search x (string s) :test #'char-equal)
  561.                (apropos2 s)))
  562.        (do-all-symbols (s)
  563.                (if (search x (string s) :test #'char-equal)
  564.                    (apropos2 s))))
  565.        (values))
  566.  
  567. #+:packages
  568. (defun apropos-list (x &optional package)
  569.        (let ((res nil))
  570.         (if package
  571.         (do-symbols (s package res)
  572.                 (if (search x (string s) :test #'char-equal)
  573.                 (push s res)))
  574.         (do-all-symbols (s res)
  575.                 (if (search x (string s) :test #'char-equal)
  576.                     (push s res))))))
  577.  
  578.  
  579. ;;;;;
  580. ;;;;; Additional Multipla Value Functions and Macros
  581. ;;;;;
  582.  
  583. (export
  584.  '(values-list multiple-value-list multiple-value-bind multiple-value-setq))
  585.  
  586. (defun values-list (x) (apply #'values x))
  587.  
  588. (defmacro multiple-value-list (form)
  589.   `(multiple-value-call #'list ,form))
  590.  
  591. (defmacro multiple-value-bind (vars form &rest body)
  592.   `(multiple-value-call #'(lambda (&optional ,@vars &rest ,(gensym)) ,@body)
  593.             ,form))
  594.  
  595. (defmacro multiple-value-setq (variables form)
  596.   (let* ((tvars (mapcar #'(lambda (x) (gensym "V")) variables))
  597.      (pairs nil))
  598.     (mapc #'(lambda (x y) (push y pairs) (push x pairs)) variables tvars)
  599.     (if (null tvars) (push (gensym) tvars))
  600.     `(multiple-value-bind ,tvars ,form (setq ,@pairs) ,(first tvars))))
  601.  
  602. (push :common *features*)
  603.